home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d880.lha / Oberon / O3Demo2.lzh / Examples / Tetriz.mod < prev    next >
Text File  |  1993-01-15  |  9KB  |  415 lines
  1. MODULE Tetriz;
  2.  
  3. IMPORT I   := Intuition,
  4.        g   := Graphics,
  5.        e   := Exec,
  6.        d   := Dos,
  7.        r   := Random,
  8.        au  := Audio,
  9.        es  := ExecSupport;
  10.  
  11. CONST
  12.   W = 10;   (* Spielfeldgröße *)
  13.   H = 20;
  14.   bw = 20;  (* Boxgröße *)
  15.   bh = 8;
  16.   w = bw*W; (* Fenstergröße *)
  17.   h = bh*H;
  18.  
  19. TYPE
  20.   SteineFeld = ARRAY 7,4 OF SET;
  21.  
  22. CONST
  23.   S = SteineFeld(
  24.         {0..3},    {0,4,8,12}, {0..3},    {0,4,8,12},
  25.         {0..2,5},  {0,4,5,8},  {1,4..6},  {1,4,5,9},
  26.         {0..2,4},  {0,4,8,9},  {2,4..6},  {0,1,5,9},
  27.         {0..2,6},  {0,1,4,8},  {0,4..6},  {1,5,8,9},
  28.         {0,1,5,6}, {1,4,5,8},  {0,1,5,6}, {1,4,5,8},
  29.         {1,2,4,5}, {0,4,5,9},  {1,2,4,5}, {0,4,5,9},
  30.         {0,1,4,5}, {0,1,4,5},  {0,1,4,5}, {0,1,4,5});
  31.  
  32. VAR
  33.   Feld: ARRAY W,H OF INTEGER;
  34.  
  35.   textattr: g.TextAttr;
  36.   nw: I.NewWindow;
  37.   window: I.WindowPtr;
  38.  
  39.   rp: g.RastPortPtr;
  40.  
  41.   MyMsgPtr: I.IntuiMessagePtr;
  42.   MyMsg: I.IntuiMessage;
  43.  
  44.   Lines: INTEGER;
  45.   HiScore: INTEGER;
  46.  
  47. CONST  (* $DataChip+ *)
  48.   RectTable = "\x7F\x80";
  49.   RectTableSize = 2;
  50.   AllocationMap = "\x01\x08\x02\x04";
  51.  
  52. VAR
  53.   AllocPort: e.MsgPortPtr;
  54.   AllocIOB:  au.IOAudioPtr;
  55.   AllocMap: UNTRACED POINTER TO ARRAY 4 OF CHAR;
  56.   Rect: UNTRACED POINTER TO ARRAY 2 OF CHAR;
  57.   AudioOpen: BOOLEAN;
  58.  
  59. TYPE
  60.   DoProc = PROCEDURE(x,y,c: INTEGER);
  61.  
  62. VAR
  63.   collCnt: INTEGER;
  64.   font: g.TextFontPtr;
  65.  
  66. (*-------------------------------------------------------------------------*)
  67. (* $Debug- *)
  68.  
  69. PROCEDURE * Box(x,y,c: INTEGER);
  70.  
  71. BEGIN
  72.   IF (x>=0) AND (y>=0) THEN
  73.     g.SetAPen(rp,c);
  74.     x := x*bw; y := y*bh;
  75.     g.RectFill(rp,x+1,y+1,x+(bw-2),y+(bh-1));
  76.   END;
  77. END Box;
  78.  
  79. PROCEDURE Do(s: SET; x,y,c: INTEGER; what: DoProc);
  80. VAR
  81.   i,j: INTEGER;
  82.   X,Y: INTEGER;
  83. BEGIN
  84.   i := 0;
  85.   REPEAT
  86.     j := 0;
  87.     REPEAT
  88.       IF 4*i+j IN s THEN
  89.         X := x+j; Y := y+i;
  90.         CASE X OF 0..W-1: CASE Y OF 0..H-1: what(X,Y,c) ELSE END ELSE END;
  91.       END;
  92.       INC(j);
  93.     UNTIL j=4;
  94.     INC(i);
  95.   UNTIL i=4;
  96. END Do;
  97.  
  98.  
  99. PROCEDURE * CollCnt(x,y,c: INTEGER);
  100. BEGIN IF Feld[x,y]=0 THEN INC(collCnt) END END CollCnt;
  101.  
  102. PROCEDURE Collide(s: SET; x,y: INTEGER): BOOLEAN;
  103. BEGIN
  104.   IF y<0 THEN RETURN FALSE END;
  105.   collCnt := 0;
  106.   Do(s,x,y,0,CollCnt);
  107.   RETURN collCnt#4;
  108. END Collide;
  109.  
  110.  
  111. PROCEDURE * AddIt(x,y,c: INTEGER);
  112. BEGIN Feld[x,y] := c END AddIt;
  113.  
  114.  
  115. PROCEDURE Draw(s: SET; x,y,c: INTEGER);
  116. BEGIN Do(s,x,y,c,Box) END Draw;
  117.  
  118.  
  119. PROCEDURE WriteInt(i: INTEGER);
  120. VAR
  121.   s: ARRAY 4 OF CHAR;
  122.   c: INTEGER;
  123. BEGIN
  124.   c := 0;
  125.   REPEAT
  126.     s[3-c] := CHR(30H + i MOD 10);
  127.     i := i DIV 10;
  128.     INC(c);
  129.   UNTIL c=4;
  130.   g.SetAPen(rp,1); g.SetBPen(rp,0); g.SetDrMd(rp,g.jam2);
  131.   g.Text(rp,s,4);
  132. END WriteInt;
  133.  
  134.  
  135. PROCEDURE CheckLine();
  136. VAR
  137.   x,y,y2: INTEGER;
  138.   lines: ARRAY H OF INTEGER;
  139.   lcnt: INTEGER;
  140. BEGIN
  141.   lcnt := 0;
  142.   y := 0;
  143.   REPEAT
  144.     x := 0;
  145.     LOOP
  146.       IF Feld[x,y]=0 THEN EXIT END;
  147.       INC(x);
  148.       IF x=W THEN lines[lcnt] := 8*y; INC(lcnt); EXIT END;
  149.     END;
  150.     INC(y);
  151.   UNTIL y=H;
  152.   IF lcnt#0 THEN
  153.  
  154.     INC(Lines,lcnt);
  155.     g.Move(rp,56,h+8); WriteInt(Lines);
  156.  
  157.     es.BeginIO(AllocIOB);
  158.     g.SetDrMd(rp,SHORTSET{g.complement});
  159.     x := 0;
  160.     REPEAT
  161.       y := 0;
  162.       REPEAT
  163.         g.RectFill(rp,0,lines[y]+1,w-1,lines[y]+7);
  164.         INC(y);
  165.       UNTIL y=lcnt;
  166.       INC(x);
  167.       d.Delay(3);
  168.     UNTIL x=8;
  169.     g.SetDrMd(rp,g.jam1);
  170.     IF e.WaitIO(AllocIOB)=0 THEN END;
  171.  
  172.     y := 19; y2 := 19; DEC(lcnt);
  173.     LOOP
  174.       IF y2<0 THEN EXIT END;
  175.       WHILE (lcnt>=0) AND (lines[lcnt]=8*y2) DO DEC(y2); DEC(lcnt) END;
  176.       IF y2<0 THEN EXIT END;
  177.       x := 0;
  178.       REPEAT
  179.         Feld[x,y] := Feld[x,y2];
  180.         INC(x);
  181.       UNTIL x=W;
  182.       DEC(y); DEC(y2);
  183.     END;
  184.     WHILE y>=0 DO
  185.       x := 0;
  186.       REPEAT
  187.         Feld[x,y] := 0;
  188.         INC(x);
  189.       UNTIL x=W;
  190.       DEC(y)
  191.     END;
  192.     y := 0;
  193.     REPEAT
  194.       x := 0;
  195.       REPEAT
  196.         Box(x,y,Feld[x,y]);
  197.         INC(x);
  198.       UNTIL x=W;
  199.       INC(y);
  200.     UNTIL y=H;
  201.   END;
  202. END CheckLine;
  203.  
  204. (* $Debug= *)
  205.  
  206.  
  207. PROCEDURE Play(): BOOLEAN;  (* TRUE wenn Q gedrückt *)
  208.  
  209. VAR
  210.   Stein: INTEGER;
  211.   x,x2,y,y2,c: INTEGER;
  212.   TimeCnt: INTEGER;
  213.   Turn,NewTurn: INTEGER;
  214.  
  215. BEGIN
  216.   g.SetAPen(rp,0);
  217.   g.RectFill(rp,0,0,w,h);
  218.  
  219.   x := 0;
  220.   REPEAT
  221.     y := 0;
  222.     REPEAT
  223.       Feld[x,y] := 0;
  224.       INC(y);
  225.     UNTIL y=H;
  226.     INC(x);
  227.   UNTIL x=W;
  228.  
  229.   Lines := 0; TimeCnt := 0;
  230.  
  231.   REPEAT
  232.     Stein := r.RND(7);
  233.     CASE window.wScreen.bitMap.depth OF
  234.     | 1: c :=               1;
  235.     | 2: c := Stein MOD 3 + 1
  236.     ELSE c := Stein       + 1
  237.     END;
  238.     Turn := 0;
  239.     x := W DIV 2 - 1; IF Stein=0 THEN DEC(x) END;
  240.     y := 0;
  241.     LOOP
  242.       IF Collide(S[Stein,Turn],x,y) THEN EXIT END;
  243.       Draw(S[Stein,Turn],x,y-1,0);
  244.       Draw(S[Stein,Turn],x,y,c);
  245.       LOOP
  246.         Draw(S[Stein,Turn],x,y,c);
  247.         IF TimeCnt>=100 THEN DEC(TimeCnt,100); EXIT END;
  248.         REPEAT
  249.           e.WaitPort(window.userPort);
  250.           MyMsgPtr := e.GetMsg(window.userPort);
  251.         UNTIL MyMsgPtr#NIL;
  252.         MyMsg := MyMsgPtr^;
  253.         e.ReplyMsg(MyMsgPtr);
  254.         IF I.intuiTicks IN MyMsg.class THEN INC(TimeCnt,15+Lines) END;
  255.         IF I.vanillaKey IN MyMsg.class THEN
  256.           Draw(S[Stein,Turn],x,y,0);
  257.           CASE MyMsg.code OF
  258.           ORD('4'):
  259.             IF (x>0) AND NOT Collide(S[Stein,Turn],x-1,y) THEN DEC(x) END |
  260.           ORD('5'):
  261.             NewTurn := (Turn + 1) MOD 4;
  262.             x2 := x; y2 := y;
  263.             IF Stein=0 THEN
  264.               IF ODD(Turn) THEN IF x2=0 THEN x2 := -1 ELSE DEC(x2); INC(y2) END
  265.                            ELSE                            INC(x2); DEC(y2) END;
  266.             END;
  267.             IF NOT Collide(S[Stein,NewTurn],x2,y2) THEN
  268.               Turn := NewTurn;
  269.               x := x2;
  270.               y := y2;
  271.             END |
  272.           ORD('6'):
  273.             IF NOT Collide(S[Stein,Turn],x+1,y) THEN INC(x) END |
  274.           ORD(' '):
  275.             LOOP
  276.               Draw(S[Stein,Turn],x,y,c);
  277.               IF Collide(S[Stein,Turn],x,y+1) THEN EXIT END;
  278.               d.Delay(1);
  279.               INC(y);
  280.               Draw(S[Stein,Turn],x,y-1,0);
  281.             END;
  282.             EXIT |
  283.           ORD('q'): RETURN TRUE |
  284.           ELSE END;
  285.         END;
  286.         IF I.closeWindow IN MyMsg.class THEN RETURN TRUE END;
  287.       END;
  288.       INC(y);
  289.     END;
  290.     IF y>0 THEN
  291.       Do(S[Stein,Turn],x,y-1,c,AddIt);
  292.       CheckLine;
  293.     END;
  294.   UNTIL y=0;
  295.  
  296.   IF Lines>HiScore THEN HiScore := Lines END;
  297.  
  298.   d.Delay(30);
  299.  
  300.   RETURN FALSE;
  301. END Play;
  302.  
  303.  
  304. (*-------------------------------------------------------------------------*)
  305.  
  306.  
  307. BEGIN
  308.  
  309.   window := NIL; HiScore := 0; AllocPort := NIL; AudioOpen := FALSE;
  310.  
  311.  
  312. (*------  Open Audio-Device:  ------*)
  313.  
  314.   AllocPort := es.CreatePort("",0);
  315.   IF AllocPort=NIL THEN HALT(0) END;
  316.  
  317.   NEW(AllocIOB);
  318.   NEW(AllocMap); AllocMap^ := AllocationMap;
  319.   AllocIOB.request.message.node.pri  := -40;
  320.   AllocIOB.request.message.replyPort := AllocPort;
  321.   AllocIOB.data   := AllocMap;
  322.   AllocIOB.length := 4;
  323.  
  324.   IF (e.OpenDevice("audio.device",0,AllocIOB,LONGSET{})#0) OR
  325.      (AllocIOB.request.error = au.allocFailed)
  326.   THEN HALT(0) END;
  327.  
  328.   AudioOpen := TRUE;
  329.  
  330.   NEW(Rect); Rect^ := RectTable;
  331.   AllocIOB.request.command := e.write;
  332.   AllocIOB.request.flags   := SHORTSET{4};
  333.   AllocIOB.data            := Rect;
  334.   AllocIOB.length          := RectTableSize;
  335.   AllocIOB.period          := 4000;
  336.   AllocIOB.cycles          := 200;
  337.   AllocIOB.volume          := 64;
  338.  
  339. (*------  Open Window:  ------*)
  340.  
  341.   nw.leftEdge   := (g.gfx.normalDisplayColumns - (w+ 8)) DIV 2;
  342.   nw.topEdge    := (g.gfx.normalDisplayRows    - (h+24)) DIV 2;
  343.   nw.width      := w+8;
  344.   nw.height     := h+24;
  345.   nw.blockPen   := 1;
  346.   nw.idcmpFlags := LONGSET{I.closeWindow,I.vanillaKey,I.intuiTicks};
  347.   nw.flags      := LONGSET{I.windowClose,I.windowDepth,I.windowDrag,I.gimmeZeroZero,I.activate};
  348.   nw.type       := {I.wbenchScreen};
  349.   NEW(nw.title);
  350.   nw.title^     := "Tetriz";
  351.   IF I.int.libNode.version>=36 THEN
  352.     window := I.OpenWindowTags(nw,I.waInnerWidth, w,
  353.                                   I.waInnerHeight,h+10,
  354.                                   0 (* Utility.done *) );
  355.   ELSE
  356.     window := I.OpenWindow(nw);
  357.   END;
  358.   IF window=NIL THEN HALT(0) END;
  359.   rp := window.rPort;
  360.   NEW(textattr.name); textattr.name^ := "topaz.font";
  361.   textattr.ySize := 8;
  362.   textattr.flags := SHORTSET{};
  363.   textattr.style := SHORTSET{};
  364.   font := g.OpenFont(textattr);
  365.   IF font=NIL THEN HALT(0) END;
  366.   g.SetFont(rp,font);
  367.  
  368. (*------  Start:  ------*)
  369.  
  370.   LOOP
  371.  
  372.     g.SetAPen(rp,0); g.SetDrMd(rp,g.jam1);
  373.     g.RectFill(rp,0,0,w,h);
  374.     g.SetAPen(rp,1);
  375.  
  376.     g.Move(rp, 20,20);  g.Text(rp,"S = Start",9);
  377.     g.Move(rp, 20,40);  g.Text(rp,"Q = Quit" ,8);
  378.     g.Move(rp, 20,60);  g.Text(rp,"© 1989 by F. Siebert",20);
  379.     g.Move(rp, 20,80);  g.Text(rp,"   AMOK Stuttgart",17);
  380.     g.Move(rp,  0,h+8); g.Text(rp,"Lines:"   ,6);
  381.     g.Move(rp,108,h+8); g.Text(rp,"Hi:"      ,3);
  382.     g.Move(rp,144,h+8); WriteInt(HiScore);
  383.  
  384.     REPEAT
  385.       REPEAT
  386.         e.WaitPort(window.userPort);
  387.         MyMsgPtr := e.GetMsg(window.userPort);
  388.       UNTIL MyMsgPtr#NIL;
  389.       MyMsg := MyMsgPtr^;
  390.       e.ReplyMsg(MyMsgPtr);
  391.     UNTIL LONGSET{I.intuiTicks}#MyMsg.class;
  392.  
  393.     IF I.vanillaKey IN MyMsg.class THEN
  394.       CASE MyMsg.code OF
  395.       ORD('s'): IF Play() THEN EXIT END |
  396.       ORD('q'): EXIT |
  397.       ELSE END;
  398.     ELSIF I.closeWindow IN MyMsg.class THEN
  399.       EXIT
  400.     END;
  401.  
  402.   END;
  403.  
  404. CLOSE
  405.  
  406.   IF window#NIL    THEN I.CloseWindow(window)    END;
  407.   IF AudioOpen     THEN e.CloseDevice(AllocIOB)  END;
  408.   IF AllocPort#NIL THEN es.DeletePort(AllocPort) END;
  409.   IF font#NIL      THEN g.CloseFont(font)        END;
  410.  
  411. END Tetriz.
  412.  
  413.  
  414.  
  415.